home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
WINRES
/
CLIPBRD.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-09-15
|
5KB
|
282 lines
unit ClipBrd;
{ Unit Clipboard, Version 1.00.001, Copyright (c) 1994 by Matthias Köppe.
}
{$G+,X+}
interface
{ Clipboard format identifiers
}
const
cf_Text = 1;
cf_Bitmap = 2;
cf_MetaFilePict = 3;
cf_SYLK = 4;
cf_DIF = 5;
cf_TIFF = 6;
cf_OEMText = 7;
cf_DIB = 8;
cf_Palette = 9;
{ Clipboard functions
}
function OpenClipboard: Boolean;
function CloseClipboard: Boolean;
function EmptyClipboard: Boolean;
function SetClipboardData(Format: Word; var Data; Size: LongInt): Boolean;
function GetClipboardDataSize(Format: Word): LongInt;
function GetClipboardData(Format: Word; var Data): Boolean;
{ Emulation control
}
procedure ForceEmulation;
{ WinOldAp-present flag
}
var
WinOldAp: Boolean;
implementation
type
PFormatEntry = ^TFormatEntry;
TFormatEntry = record
feNext: PFormatEntry;
feFormat: Word;
feData: pointer;
feSize: LongInt
end;
const
EmClipboard: PFormatEntry = nil;
var
SaveExit: pointer;
procedure DetectWinOldAp; near; assembler;
Asm
MOV AX, 1700H
INT 2FH
CMP AX, 1700H
JZ @@1
MOV AL, 1
@@1: MOV WinOldAp, AL
End;
procedure FindEntry; near; assembler;
{ In DX format id
Out ES:SI PFormatEntry
}
Asm
LES SI, EmClipboard
@@2: MOV AX, ES
OR AX, SI
JZ @@1
CMP DX, ES:[SI].TFormatEntry.feFormat
JE @@1
LES SI, ES:[SI].TFormatEntry.feNext
JMP @@2
@@1:
End;
procedure FreeMemProc(p: pointer; Size: Word); near;
Begin
FreeMem(p, Size)
End;
function GetMemProc(Size: Word): pointer; near;
var
p: pointer;
Begin
GetMem(p, Size);
GetMemProc := p
End;
function OpenClipboard; assembler;
Asm
CMP WinOldAp, 0
JZ @em
MOV AX, 1701H
INT 2FH
OR AX, AX
JZ @end
@em: MOV AL, 1
@end:
End;
function CloseClipboard; assembler;
Asm
CMP WinOldAp, 0
JZ @em
MOV AX, 1708H
INT 2FH
OR AX, AX
JZ @end
@em: MOV AL, 1
@end:
End;
function EmptyClipboard; assembler;
Asm
CMP WinOldAp, 0
JZ @em
MOV AX, 1702H
INT 2FH
OR AX, AX
JNZ @@1
JMP @end
@em: LES SI, EmClipboard
MOV EmClipboard.Word, 0
MOV EmClipboard.2.Word, 0
@@2: MOV AX, ES
OR AX, SI
JZ @@1
PUSH ES:[SI].TFormatEntry.feNext.2.Word
PUSH ES:[SI].TFormatEntry.feNext.Word
PUSH ES
PUSH SI
PUSH ES:[SI].TFormatEntry.feData.2.Word
PUSH ES:[SI].TFormatEntry.feData.Word
PUSH ES:[SI].TFormatEntry.feSize.Word
CALL FreeMemProc
PUSH TYPE TFormatEntry
CALL FreeMemProc
POP SI
POP ES
JMP @@2
@@1: MOV AL, 1
@end:
End;
function SetClipboardData; assembler;
Asm
MOV DX, Format
CMP WinOldAp, 0
JZ @em
MOV AX, 1703H
LES BX, Data
MOV CX, Size.Word
MOV SI, Size.2.Word
INT 2FH
OR AX, AX
JZ @end
PUSH Data.2.Word
PUSH Data.Word
PUSH Size.Word
CALL FreeMemProc
JMP @@3
@em: CALL FindEntry
MOV AX, ES
OR AX, SI
JZ @@1
PUSH ES
PUSH SI
PUSH ES:[SI].TFormatEntry.feData.2.Word
PUSH ES:[SI].TFormatEntry.feData.Word
PUSH ES:[SI].TFormatEntry.feSize.Word
CALL FreeMemProc
POP DI
POP ES
ADD DI, TFormatEntry.feData
CLD
JMP @@2
@@1: PUSH WORD PTR Size
CALL GetMemProc
MOV ES, DX
MOV DI, AX
CLD
XCHG AX, EmClipboard.Word
STOSW
MOV AX, DX
XCHG AX, EmClipboard.2.Word
STOSW
MOV AX, Format
STOSW
@@2: MOV AX, Data.Word
STOSW
MOV AX, Data.2.Word
STOSW
MOV AX, Size.Word
STOSW
MOV AX, Size.2.Word
STOSW
@@3: MOV AL, 1
@end:
End;
function GetClipboardDataSize; assembler;
Asm
MOV DX, Format
CMP WinOldAp, 0
JZ @em
MOV AX, 1704H
INT 2FH
JMP @end
@em: CALL FindEntry
MOV AX, ES
MOV DX, SI
OR AX, DX
JZ @end
MOV AX, ES:[SI].TFormatEntry.feSize.Word
MOV DX, ES:[SI].TFormatEntry.feSize.2.Word
@end:
End;
function GetClipboardData; assembler;
Asm
MOV DX, Format
CMP WinOldAp, 0
JZ @em
MOV AX, 1705H
LES BX, Data
INT 2FH
OR AX, AX
JNZ @@2
JMP @end
@em: CALL FindEntry
MOV AX, ES
OR AX, SI
JZ @end
MOV CX, ES:[SI].TFormatEntry.feSize.Word
SHR CX, 1
PUSH DS
PUSHF
LDS SI, ES:[SI].TFormatEntry.feData
LES DI, Data
CLD
REP MOVSW
POPF
JNC @@1
MOVSB
@@1: POP DS
@@2: MOV AL, 1
@end:
End;
procedure ClipExit; far;
Begin
EmptyClipboard;
ExitProc := SaveExit
End;
procedure InstallExit; near;
Begin
SaveExit := ExitProc;
ExitProc := @ClipExit
End;
procedure ForceEmulation;
Begin
If WinOldAp then Begin
InstallExit;
WinOldAp := false
End
End;
Begin
DetectWinOldAp;
If not WinOldAp then InstallExit
End.